COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 A simple Combinator interpreter based on production rules.
C00011 ENDMK
C⊗;
;;; A simple Combinator interpreter based on production rules.

(declare (special productions spaces *A *B *C) (*lexpr %umatch)
	 (*expr %instantiate)(fixnum spaces))

(eval-when (compile) (load "struct.fas[mac,lsp]"))

(setq productions () spaces 0)

(defun n-spaces (n)
       (declare (fixnum n))
       (do ((n n (1- n)))
	   ((= n 0))
	   (tyo #o40)))

(defstruct production 
	  (antecedent ())
	  (consequent ())
	  (action ()))

(push (make-production antecedent '(I ?x *r)
		       consequent '(?x *r)) productions)

(push (make-production antecedent '(C ?f ?x ?y *r)
		       consequent '(?f ?y ?x *r)) productions)

(push (make-production antecedent '(W ?f ?x *r)
		       consequent '(?f ?x ?x *r)) productions)

(push (make-production antecedent '(B ?f ?g ?x *r)
		       consequent '(?f (?g ?x) *r)) productions)

(push (make-production antecedent '(K ?x ?y *r)
		       consequent '(?x *r)) productions)

(push (make-production antecedent '(S ?f ?g ?x *r)
		       consequent '(?f ?x (?g ?x) *r)) productions)

(push (make-production antecedent '(PHI ?f ?a ?b ?x *r)
		       consequent '(?f (?a ?x) (?b ?x) *r)) productions)

(push (make-production antecedent '(PSI ?f ?g ?x ?y *r)
		       consequent '(?f (?g ?x) (?g ?y) *r)) productions)

(push (make-production antecedent '((*x) *r)
		       consequent '(*x *r)) productions)

(push (make-production antecedent '(*b (Z 0) *r)
		       consequent '(*b (K I) *r)) productions)

(push (make-production antecedent '(*b (Z ($r ?n (lambda (x)(or (not (numberp x))
								(not (zerop x))))))
				       *r)
		       consequent '(*b (S B (Z ?n)) *r)
		       action '(cond ((numberp ?n)(setq ?n (1- ?n))) 
				     (t (setq ?n `(- ,?n 1))))) productions)

(push (make-production antecedent '(*b (Z (+ ?n 1))
				       *r)
		       consequent '(*b (S B (Z ?n)) *r)) productions)

(push (make-production antecedent '(D2 ?x ?y ?z *r)
		       consequent '(?z (K ?y) ?x *r)) productions)

(push (make-production antecedent '(Y f *r)
		       consequent '(W S (B W B) f *r)) productions)

(defun reduce (form)
       (let ((original form))
	    (terpri)(princ "Reducing: ")(princ form)
	    (print form)
	    (do ((form (process form)
		       (process form))
		 (old-form form form))
		((equal form old-form) 
		 (terpri)
		 (princ original) (princ " = ") (princ form)))))

(defun process (form)
       (cond ((%umatch '(*a (*b) *c)
		       form)
	      (let ((*A *A) 
		    (old-*B *B)
		    (spaces (1+ spaces))
		    (*C *C))
		   (terpri)(n-spaces spaces)
		   (princ spaces)(princ " ")
		   (princ "Processing: ")(princ *B)
		   (setq *B (process *B))
		   (terpri)
		   (n-spaces spaces)(princ spaces)(princ " ")
		   (princ old-*B)(princ " = ")(princ *B))
	      (setq form `(,@*A (,@*B) ,@*C))))
       (do ((productions productions (cdr productions)))
	   ((null productions) 
	    form)
	   (cond ((%umatch
		   (antecedent (car productions))
		   form)
		  (eval (action (car productions)))
		  (setq form (%instantiate (consequent (car productions))))
		  (terpri)(cond ((not (= spaces 0))
				 (n-spaces spaces)
				 (princ spaces)
				 (princ " ")))
		  (princ form)))))

(defun reducible (form1 form2)
       (let (hist1 hist2 intersect
		   (original-form1 form1)
		   (original-form2 form2))
	    (push form1 hist1)
	    (push form2 hist2)
	    (do ((form1 (apply1-reduction form1)
			(cond ((equal form1 old-form1) form1)
			      (t (apply1-reduction form1))))
		 (old-form1 form1 form1)
		 (old-form2 form2 form2)
		 (form2 (apply1-reduction form2)
			(cond ((equal form2 old-form2) form2)
			      (t (apply1-reduction form2)))))
		((or (equal form1 original-form2)
		     (equal form2 original-form1)
		     (setq intersect (intersection hist1 hist2)))
		 (cond ((equal form1 original-form2)
			(show-result (nreverse hist1)))
		       ((equal form2 original-form1)
			(show-result hist2))
		       (t (show-results hist1 hist2 intersect))))
		(cond ((equal form1 original-form1))
		      (t (push form1 hist1)))
		(cond ((equal form2 original-form2))
		      (t (push form2 hist2))))))

(defun apply1-reduction (form)
       (cond ((%umatch '(*a (*b) *c)
		       form)
	      (let ((*A *A) 
		    (*C *C))
		   (setq *b (apply1-reduction *B)))
	      (setq form `(,@*A (,@*B) ,@*C))))
        (do ((productions productions (cdr productions)))
	    ((null productions) 
	     form)
	    (cond ((%umatch
		    (antecedent (car productions))
		    form)
		   (eval (action (car productions)))
		   (return (%instantiate (consequent (car productions))))))))

(defun intersection (l1 l2)
       (do ((l1 l1 (cdr l1)))
	   ((null l1) ())
	   (cond ((member (car l1) l2)
		  (return (car l1))))))

(defun show-results (l1 l2 intersect)
       (do ((a (nreverse l1) (cdr a)))
	   ((equal (car a) intersect))
	   (print (car a)))
       (print '-)
       (do ((l2 l2 (cdr l2)))
	   ((equal (car l2) intersect)
	    (do ((l2 l2 (cdr l2)))
		((null l2) t)
		(print (car l2))))))

(defun show-result (l)
       (do ((l l (cdr l)))
	   ((null l) t)
	   (print (car l))))